home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / xlisp-2.1 / pp.lsp < prev    next >
Encoding:
Text File  |  1991-10-06  |  12.2 KB  |  358 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         pp.lsp
  5. ; RCS:          $Header: $
  6. ; Description:  PP.LSP -- a pretty-printer for XLISP.
  7. ; Author:       Adapted by Jim Chapman (Bix: jchapman) from a program written
  8. ;        originally for IQLISP by Don Cohen.
  9. ;        Modified for XLISP 2.0 by David Betz.
  10. ; Created:      Sat Oct  5 21:05:41 1991
  11. ; Modified:     Sat Oct  5 21:09:05 1991 (Niels Mayer) mayer@hplnpm
  12. ; Language:     Lisp
  13. ; Package:      N/A
  14. ; Status:       X11r5 contrib tape release
  15. ;
  16. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  17. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  18. ; Copyright (c) 1984, Don Cohen.
  19. ; Copyright (c) 1987, Jim Chapman. 
  20. ;
  21. ; Permission to use, copy, modify, distribute, and sell this software and its
  22. ; documentation for any purpose is hereby granted without fee, provided that
  23. ; the above copyright notice appear in all copies and that both that
  24. ; copyright notice and this permission notice appear in supporting
  25. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  26. ; used in advertising or publicity pertaining to distribution of the software
  27. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  28. ; makes no representations about the suitability of this software for any
  29. ; purpose.  It is provided "as is" without express or implied warranty.
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. ; In addition to the pretty-printer itself, this file contains a few functions
  33. ; that illustrate some simple but useful applications.
  34.  
  35. ; The basic function accepts two arguments:
  36.  
  37. ;      (PP OBJECT STREAM)
  38.  
  39. ; where OBJECT is any Lisp expression, and STREAM optionally specifies the
  40. ; output (default is *standard-output*).
  41.  
  42. ; PP-FILE pretty-prints an entire file.  It is what I used to produce this
  43. ; file (before adding the comments manually).  The syntax is:
  44.  
  45. ;       (PP-FILE "filename" STREAM)
  46.  
  47. ; where the file name must be a string or quoted, and STREAM, again, is the
  48. ; optional output destination.
  49.  
  50. ; PP-DEF works just like PP, except its first argument is assumed to be the
  51. ; name of a function or macro, which is translated back into the original
  52. ; DEFUN or DEFMACRO form before printing.
  53.  
  54.  
  55. ; MISCELLANEOUS USAGE AND CUSTOMIZATION NOTES:
  56.  
  57. ; 1.  The program uses tabs whenever possible for indentation.
  58. ;     This greatly reduces the cost of the blank space.  If your output
  59. ;     device doesn't support tabs, set TABSIZE to NIL -- which is what I
  60. ;     did when I pretty-printed this file, because of uncertainty 
  61. ;     about the result after uploading.
  62.  
  63. ; 2.  Printmacros are used to handle special forms.  A printmacro is not
  64. ;     really a macro, just an ordinary lambda form that is stored on the
  65. ;     target symbol's property list.  The default printer handles the form
  66. ;     if there is no printmacro or if the printmacro returns NIL.
  67.  
  68. ; 3.  Note that all the pretty-printer subfunctions, including the
  69. ;     the printmacros, return the current column position.
  70.  
  71. ; 4.  Miser mode is not fully implemented in this version, mainly because  
  72. ;     lookahead was too slow.  The idea is, if the "normal" way of
  73. ;     printing the current expression would exceed the right margin, then
  74. ;     use a mode that conserves horizontal space.
  75.  
  76. ; 5.  When PP gets to the last 8th of the line and has more to print than
  77. ;     fits on the line, it starts near the left margin.  This is not 
  78. ;     wonderful, but neither are the alternatives.  If you have a better
  79. ;     idea, go for it.
  80.  
  81. ;  6. Storage requirements are about 1450 cells to load.  
  82.  
  83. ;  7. I tested this with XLISP 1.7 on an Amiga.
  84.  
  85. ;(DEFUN SYM-FUNCTION (X)    ;for Xlisp 1.7
  86. ;    (CAR (SYMBOL-VALUE X)))
  87. (DEFUN SYM-FUNCTION (X)        ;for Xlisp 2.0
  88.     (GET-LAMBDA-EXPRESSION (SYMBOL-FUNCTION X)))
  89.  
  90. (SETQ TABSIZE 8)    ;set this to NIL for no tabs
  91.  
  92. (SETQ MAXSIZE 50)    ;for readability, PP tries not to print more
  93.             ;than this many characters on a line
  94.  
  95. (SETQ MISER-SIZE 2)    ;the indentation in miser mode
  96.  
  97. (SETQ MIN-MISER-CAR 4)    ;used for deciding when to use miser mode
  98.  
  99. (SETQ MAX-NORMAL-CAR 9)    ;ditto
  100.  
  101.  
  102. ; The following function prints a file
  103.  
  104. (DEFUN PP-FILE (FILENAME &OPTIONAL STREAMOUT)
  105.     (OR STREAMOUT (SETQ STREAMOUT *STANDARD-OUTPUT*))
  106.     (PRINC "; Listing of " STREAMOUT)
  107.     (PRINC FILENAME STREAMOUT)
  108.     (TERPRI STREAMOUT)
  109.     (TERPRI STREAMOUT)
  110.     (DO* ((FP (OPENI FILENAME)) (EXPR (READ FP) (READ FP)))
  111.          ((NULL EXPR) (CLOSE FP))
  112.       (PP EXPR STREAMOUT)
  113.       (TERPRI STREAMOUT)))
  114.  
  115.  
  116. ; Print a lambda or macro form as a DEFUN or DEFMACRO:
  117.  
  118. (DEFMACRO PP-DEF (WHO &OPTIONAL STREAM)
  119.     `(PP (MAKE-DEF ,WHO) ,STREAM))
  120.  
  121. (DEFMACRO MAKE-DEF (NAME &AUX EXPR TYPE)
  122.     (SETQ EXPR (SYM-FUNCTION NAME))
  123.     (SETQ TYPE
  124.           (CADR (ASSOC (CAR EXPR)
  125.                        '((LAMBDA DEFUN) (MACRO DEFMACRO)))))
  126.     (LIST 'QUOTE
  127.           (APPEND (LIST TYPE NAME) (CDR EXPR))))
  128.  
  129.  
  130.  
  131. ; The pretty-printer high level function:
  132.  
  133. (DEFUN PP (X &OPTIONAL STREAM)
  134.     (OR STREAM (SETQ STREAM *STANDARD-OUTPUT*))
  135.     (PP1 X STREAM 1 80)
  136.     (TERPRI STREAM)
  137.     T)
  138.  
  139. (DEFUN PP1 (X STREAM CURPOS RMARGIN &AUX SIZE POSITION WIDTH)
  140.     (COND ((NOT (CONSP X)) (PRIN1 X STREAM) (+ CURPOS (FLATSIZE X)))
  141.           ((PRINTMACROP X STREAM CURPOS RMARGIN))
  142.           ((AND (> (FLATSIZE X) (- RMARGIN CURPOS))
  143.                 (< (* 8 (- RMARGIN CURPOS)) RMARGIN))
  144.            (SETQ SIZE (+ (/ RMARGIN 8) (- CURPOS RMARGIN)))
  145.            (MOVETO STREAM CURPOS SIZE)
  146.            (SETQ POSITION (PP1 X STREAM SIZE RMARGIN))
  147.            (MOVETO STREAM POSITION SIZE))
  148.           (T (PRINC "(" STREAM)
  149.              (SETQ POSITION
  150.                    (PP1 (CAR X) STREAM (1+ CURPOS) RMARGIN))
  151.              (COND ((AND (>= (SETQ WIDTH (- RMARGIN POSITION))
  152.                              (SETQ SIZE (FLATSIZE (CDR X))))
  153.                          (<= SIZE MAXSIZE))
  154.                     (PP-REST-ACROSS (CDR X) STREAM POSITION RMARGIN))
  155.                    ((CONSP (CAR X))
  156.                     (MOVETO STREAM POSITION CURPOS)
  157.                     (PP-REST (CDR X) STREAM CURPOS RMARGIN))
  158.                    ((> (- POSITION CURPOS) MAX-NORMAL-CAR)
  159.                     (MOVETO STREAM POSITION (+ CURPOS MISER-SIZE))
  160.                     (PP-REST (CDR X) STREAM (+ CURPOS MISER-SIZE) RMARGIN))
  161.                    (T (PP-REST (CDR X) STREAM POSITION RMARGIN))))))
  162.  
  163. ; MOVETO controls indentating and tabbing.
  164.  
  165. (DEFUN MOVETO (STREAM CURPOS GOALPOS)
  166.     (COND ((> CURPOS GOALPOS)
  167.            (TERPRI STREAM)
  168.            (SETQ CURPOS 1)
  169.            (IF TABSIZE
  170.                (DO NIL
  171.                    ((< (- GOALPOS CURPOS) TABSIZE))
  172.                  (PRINC "\t" STREAM)
  173.                  (SETQ CURPOS (+ CURPOS TABSIZE))))))
  174.     (SPACES (- GOALPOS CURPOS) STREAM)
  175.     GOALPOS)
  176.  
  177. (DEFUN SPACES (N STREAM)
  178.     (DOTIMES (I N) (PRINC " " STREAM)))
  179.  
  180. (DEFUN PP-REST-ACROSS (X STREAM CURPOS RMARGIN &AUX POSITION)
  181.     (SETQ POSITION CURPOS)
  182.     (PROG NIL
  183.       LP
  184.       (COND ((NULL X) (PRINC ")" STREAM) (RETURN (1+ POSITION)))
  185.             ((NOT (CONSP X))
  186.              (PRINC " . " STREAM)
  187.              (PRIN1 X STREAM)
  188.              (PRINC ")" STREAM)
  189.              (RETURN (+ 4 POSITION (FLATSIZE X))))
  190.             (T (PRINC " " STREAM)
  191.                (SETQ POSITION
  192.                      (PP1 (CAR X) STREAM (1+ POSITION) RMARGIN))
  193.                (SETQ X (CDR X))
  194.                (GO LP)))))
  195.  
  196. (DEFUN PP-REST (X STREAM CURPOS RMARGIN &AUX POSITION POS2)
  197.     (SETQ POSITION CURPOS)
  198.     (PROG NIL
  199.       LP
  200.       (COND ((NULL X) (PRINC ")" STREAM) (RETURN (1+ POSITION)))
  201.             ((NOT (CONSP X))
  202.              (AND (> (FLATSIZE X) (- (- RMARGIN POSITION) 3))
  203.                   (SETQ POSITION (MOVETO STREAM POSITION CURPOS)))
  204.              (PRINC " . " STREAM)
  205.              (PRIN1 X STREAM)
  206.              (PRINC ")" STREAM)
  207.              (RETURN (+ POSITION 4 (FLATSIZE X))))
  208.             ((AND (NOT (CONSP (CAR X)))
  209.                   (<= (SETQ POS2 (+ 1 POSITION (FLATSIZE (CAR X))))
  210.                       RMARGIN)
  211.                   (<= POS2 (+ CURPOS MAXSIZE)))
  212.              (PRINC " " STREAM)
  213.              (PRIN1 (CAR X) STREAM)
  214.              (SETQ POSITION POS2))
  215.             (T (MOVETO STREAM POSITION (1+ CURPOS))
  216.                (SETQ POSITION
  217.                      (PP1 (CAR X) STREAM (1+ CURPOS) RMARGIN))))
  218.       (COND ((AND (CONSP (CAR X)) (CDR X))
  219.              (SETQ POSITION (MOVETO STREAM POSITION CURPOS))))
  220.       (SETQ X (CDR X))
  221.       (GO LP)))
  222.  
  223.  
  224. ; PRINTMACROP is the printmacro interface routine.  Note that the
  225. ; called function has the same argument list as PP1.  It may either
  226. ; decide not to handle the form, by returning NIL (and not printing)
  227. ; or it may print the form and return the resulting position.
  228.  
  229. (DEFUN PRINTMACROP (X STREAM CURPOS RMARGIN &AUX MACRO)
  230.     (AND (SYMBOLP (CAR X))
  231.          (SETQ MACRO (GET (CAR X) 'PRINTMACRO))
  232.          (APPLY MACRO (LIST X STREAM CURPOS RMARGIN))))
  233.  
  234. ; The remaining forms define various printmacros.
  235.  
  236. (DEFUN PP-BINDING-FORM (X STREAM POS RMAR &AUX CUR)
  237.     (SETQ CUR POS)
  238.     (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
  239.                 (<= (FLATSIZE X) MAXSIZE)) NIL)
  240.           ((> (LENGTH X) 2)
  241.            (PRINC "(" STREAM)
  242.            (PRIN1 (CAR X) STREAM)
  243.            (PRINC " " STREAM)
  244.            (SETQ CUR
  245.                  (PP1 (CADR X)
  246.                       STREAM
  247.                       (+ 2 POS (FLATSIZE (CAR X)))
  248.                       RMAR))
  249.            (MOVETO STREAM CUR (+ POS 1))
  250.            (PP-REST (CDDR X) STREAM (+ POS 1) RMAR))))
  251.  
  252. (DEFUN PP-DO-FORM (X STREAM POS RMAR &AUX CUR POS2)
  253.     (SETQ CUR POS)
  254.     (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
  255.                 (<= (FLATSIZE X) MAXSIZE)) NIL)
  256.           ((> (LENGTH X) 2)
  257.            (PRINC "(" STREAM)
  258.            (PRIN1 (CAR X) STREAM)
  259.            (PRINC " " STREAM)
  260.            (SETQ POS2 (+ 2 POS (FLATSIZE (CAR X))))
  261.            (SETQ CUR (PP1 (CADR X) STREAM POS2 RMAR))
  262.            (MOVETO STREAM CUR POS2)
  263.            (SETQ CUR (PP1 (CADDR X) STREAM POS2 RMAR))
  264.            (MOVETO STREAM CUR (+ POS 1))
  265.            (PP-REST (CDDDR X) STREAM (+ POS 1) RMAR))))
  266.  
  267. (DEFUN PP-DEFINING-FORM (X STREAM POS RMAR &AUX CUR)
  268.     (SETQ CUR POS)
  269.     (COND ((AND (>= (- RMAR POS) (FLATSIZE X))
  270.                 (<= (FLATSIZE X) MAXSIZE)) NIL)
  271.           ((> (LENGTH X) 3)
  272.            (PRINC "(" STREAM)
  273.            (PRIN1 (CAR X) STREAM)
  274.            (PRINC " " STREAM)
  275.            (PRIN1 (CADR X) STREAM)
  276.            (PRINC " " STREAM)
  277.            (SETQ CUR
  278.                  (PP1 (CADDR X)
  279.                       STREAM
  280.                       (+ 3 POS (FLATSIZE (CAR X)) (FLATSIZE (CADR X)))
  281.                       RMAR))
  282.            (MOVETO STREAM CUR (+ 3 POS))
  283.            (PP-REST (CDDDR X) STREAM (+ 3 POS) RMAR))))
  284.  
  285. (PUTPROP 'QUOTE
  286.          '(LAMBDA (X STREAM POS RMARGIN)
  287.             (COND ((AND (CDR X) (NULL (CDDR X)))
  288.                    (PRINC "'" STREAM)
  289.                    (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
  290.          'PRINTMACRO)
  291.  
  292. (PUTPROP 'BACKQUOTE
  293.          '(LAMBDA (X STREAM POS RMARGIN)
  294.             (COND ((AND (CDR X) (NULL (CDDR X)))
  295.                    (PRINC "`" STREAM)
  296.                    (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
  297.          'PRINTMACRO)
  298.  
  299. (PUTPROP 'COMMA
  300.          '(LAMBDA (X STREAM POS RMARGIN)
  301.             (COND ((AND (CDR X) (NULL (CDDR X)))
  302.                    (PRINC "," STREAM)
  303.                    (PP1 (CADR X) STREAM (1+ POS) RMARGIN))))
  304.          'PRINTMACRO)
  305.  
  306. (PUTPROP 'COMMA-AT
  307.          '(LAMBDA (X STREAM POS RMARGIN)
  308.             (COND ((AND (CDR X) (NULL (CDDR X)))
  309.                    (PRINC ",@" STREAM)
  310.                    (PP1 (CADR X) STREAM (+ POS 2) RMARGIN))))
  311.          'PRINTMACRO)
  312.  
  313. (PUTPROP 'FUNCTION
  314.          '(LAMBDA (X STREAM POS RMARGIN)
  315.             (COND ((AND (CDR X) (NULL (CDDR X)))
  316.                    (PRINC "#'" STREAM)
  317.                    (PP1 (CADR X) STREAM (+ POS 2) RMARGIN))))
  318.          'PRINTMACRO)
  319.  
  320. (PUTPROP 'PROG
  321.          'PP-BINDING-FORM
  322.          'PRINTMACRO)
  323.  
  324. (PUTPROP 'PROG*
  325.          'PP-BINDING-FORM
  326.          'PRINTMACRO)
  327.  
  328. (PUTPROP 'LET
  329.          'PP-BINDING-FORM
  330.          'PRINTMACRO)
  331.  
  332. (PUTPROP 'LET*
  333.          'PP-BINDING-FORM
  334.          'PRINTMACRO)
  335.  
  336. (PUTPROP 'LAMBDA
  337.          'PP-BINDING-FORM
  338.          'PRINTMACRO)
  339.  
  340. (PUTPROP 'MACRO
  341.          'PP-BINDING-FORM
  342.          'PRINTMACRO)
  343.  
  344. (PUTPROP 'DO 'PP-DO-FORM 'PRINTMACRO)
  345.  
  346. (PUTPROP 'DO*
  347.          'PP-DO-FORM
  348.          'PRINTMACRO)
  349.  
  350. (PUTPROP 'DEFUN
  351.          'PP-DEFINING-FORM
  352.          'PRINTMACRO)
  353.  
  354. (PUTPROP 'DEFMACRO
  355.          'PP-DEFINING-FORM
  356.          'PRINTMACRO)
  357.  
  358.